(in-package :gwee)

(defclass tree (view foreground-mixin background-mixin)
  ((root-nodes :initarg :roots :accessor tree-roots)
   (selected :initform nil :accessor tree-selected)
   (expndedp-function :initarg :expandedp-function :accessor tree-expandedp-function)
   (format-function :initarg :format-function :accessor tree-format-function)
   (select-function :initarg :select-function :accessor tree-select-function)
   (children-function :initarg :children-function :accessor tree-children-function)))

(defclass tree-expander (view background-mixin)
  ((state :initform :collapsed :initarg :state :accessor tree-expander-state))
  (:default-initargs
   :border-color *default-foreground-color*
   :width 11
   :height 11))

(defclass tree-node (row-layout)
  ((expandedp :initform nil :initarg :expandedp :accessor tree-node-expandedp)
   (subview-cache :initform nil :accessor tree-node-subview-cache)
   (tree :initarg :tree :accessor tree-node-tree)
   (obj :initarg :obj :accessor tree-node-obj)
   (name :initarg :name :accessor tree-node-name)))

(defclass tree-node-wrapper (view)
  ((tree :initarg :tree :accessor tree-node-wrapper-tree)
   (obj :initarg :obj :accessor tree-node-wrapper-obj)))

(defmethod (setf tree-expander-state) :after (value (obj tree-node))
  (setf (view-needs-update-p obj) t))

(defmethod draw-view ((view tree-expander))
  (sdl:draw-hline (+ (view-cache-top-x view) 2)
		  (+ (view-cache-top-x view) -3 (view-width view))
		  (+ (view-cache-top-y view) (floor (view-height view) 2))
		  :color *default-foreground-color*)
  (when (eq (tree-expander-state view) :collapsed)
    (sdl:draw-vline (+ (view-cache-top-x view) (floor (view-width view) 2))
		    (+ (view-cache-top-y view) 2)
		    (+ (view-cache-top-y view) -3 (view-height view))
		    :color *default-foreground-color*)))

(defmethod mouse-press-event ((view tree-expander) button x y)
  (declare (ignore button x y))
  (with-slots (parent) view
    (if (tree-node-expandedp parent)
	(tree-node-collapse parent)
	(tree-node-expand parent))))

(defmethod mouse-press-event ((view tree-node-wrapper) button x y)
  (let ((last (tree-selected (tree-node-wrapper-tree view))))
    (when last
      (setf (background-color (car (view-subviews (tree-selected (tree-node-wrapper-tree view))))) *default-background-color*
	    (foreground-color (car (view-subviews (tree-selected (tree-node-wrapper-tree view))))) *default-foreground-color*
	    (view-needs-update-p (tree-selected (tree-node-wrapper-tree view))) t))
    (setf (tree-selected (tree-node-wrapper-tree view)) view
	  (foreground-color (car (view-subviews view))) *default-background-color*
	  (background-color (car (view-subviews view))) *default-foreground-color*
	  (view-needs-update-p view) t)
    (when (slot-boundp (tree-node-wrapper-tree view) 'select-function)
      (funcall (tree-select-function (tree-node-wrapper-tree view))
	       (tree-node-wrapper-tree view)
	       (tree-node-wrapper-obj view)
	       (when last
		 (tree-node-wrapper-obj last))))))

(defun tree-build-node (tree obj expandedp)
  (let ((children (funcall (tree-children-function tree) obj))
	(name (funcall (tree-format-function tree) obj)))
    (make-instance
     'tree-node
     :tree tree
     :obj obj
     :name name
     :expandedp expandedp
     :auto-resize t
     :border-color nil
     :cell-gravity :top
     :subviews
     (list
      (if children
	  (make-instance 'tree-expander :state expandedp)
	  (make-instance 'view :width 11 :height 11))
      (make-instance 'column-layout
		     :border-color nil
		     :cell-gravity :top
		     :auto-resize t
		     :subviews
		     (cons
		      ;; FIXME: is it better to wrap it or use hooks to detect mouse clicks?
		      (let ((txt (make-instance 'text-area :border-color nil :data name :wrap-p nil)))
			(make-instance 'tree-node-wrapper
				       :tree tree
				       :obj obj
				       :width (view-width txt)
				       :height (view-height txt)
				       :subviews (list txt)))
		      (when expandedp
			(mapcar (lambda (x) (tree-build-node tree x (when (tree-expandedp-function tree)
								      (funcall (tree-expandedp-function tree)))))
				children))))))))

(defun tree-node-collapse (node)
  (setf (tree-node-expandedp node)
	nil
	(tree-expander-state (first (view-subviews node))) :collapsed
;; 	(view-height (second (view-subviews node))) (view-height (first (view-subviews (second (view-subviews node)))))
	(tree-node-subview-cache node) (cdr (view-subviews (second (view-subviews node))))
	(view-subviews (second (view-subviews node)))
	(list (first (view-subviews (second (view-subviews node)))))
	(view-needs-update-p (tree-node-tree node)) t))

(defun tree-node-expand (node)
  (setf (tree-node-expandedp node)
	t
	(tree-expander-state (first (view-subviews node))) :expanded
	(view-subviews (second (view-subviews node)))
	(cons
	 (first (view-subviews (second (view-subviews node))))
	 (or (tree-node-subview-cache node)
	     (mapcar (lambda (x)
		       (tree-build-node (tree-node-tree node) x nil))
		     (funcall (tree-children-function (tree-node-tree node)) (tree-node-obj node)))))
;; 	(view-height (second (view-subviews node))) (reduce '+ (view-subviews (second (view-subviews node))) :key 'view-height)
	(view-needs-update-p (tree-node-tree node)) t))

(defmethod shared-initialize :after ((obj tree) slot-names &key)
  ;; build the initial tree state
  (make-instance 'column-layout
		 :parent obj
		 :auto-resize t
		 :cell-gravity :top
		 :subviews (mapcar (lambda (x) (tree-build-node obj x
								(when (tree-expandedp-function obj)
								  (funcall (tree-expandedp-function obj)))))
				   (tree-roots obj))))

(defun tree-refresh (tree)
  (setf (view-subviews (first (view-subviews tree)))
	(mapcar (lambda (x) (tree-build-node tree x 
					     (when (tree-expandedp-function tree)
					       (funcall (tree-expandedp-function tree)))))
		(tree-roots tree))))
